home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 January / Macworld (1998-01).dmg / Shareware World / Comms & Internet / HTML mode 2.0 etc. / hctsmslShared.tcl < prev    next >
Encoding:
Text File  |  1997-09-22  |  29.2 KB  |  934 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  HTML and CSS mode - tools for editing Cascading Style Sheets
  4.  # 
  5.  #  FILE: "hctsmslShared.tcl"
  6.  #                                    created: 97-04-05 18.39.51 
  7.  #                                last update: 97-09-06 17.06.45 
  8.  #  Author: Johan Linde
  9.  #  E-mail: <jl@theophys.kth.se>
  10.  #     www: <http://bach.theophys.kth.se/~jl/Alpha.html>
  11.  #  
  12.  # Version: 2.0 and 1.0
  13.  # 
  14.  # Copyright 1996, 1997 by Johan Linde
  15.  #  
  16.  # This software may be used freely, and distributed freely, as long as the 
  17.  # receiver is not obligated in any way by receiving it.
  18.  #  
  19.  # If you make improvements to this file, please share them!
  20.  # 
  21.  # ###################################################################
  22.  ##
  23.  
  24. proc hctsmslShared.tcl {} {}
  25.  
  26. # ◊◊◊◊ Change below for new system §3 ◊◊◊◊ #
  27.  
  28. # A list of URLs, cached, to pick from for insertion
  29. newModeVar HTML URLs            {}    0
  30.  
  31. # Home pages, set the old one if it exists.
  32. if {[info exists homePagePath] && [string length $homePagePath] && 
  33. [info exists HTMLmodeVars(baseURL)] && [string length $HTMLmodeVars(baseURL)]} {
  34.     if {![info exists HTMLmodeVars(basePath)]} {set HTMLmodeVars(basePath) ""}
  35.     newModeVar HTML homePages [list [list [string trimright $homePagePath :] $HTMLmodeVars(baseURL) $HTMLmodeVars(basePath) "index.html"]] 0
  36.     lappend modifiedModeVars {homePages HTMLmodeVars}
  37. } else {
  38.     newModeVar HTML homePages {} 0
  39. }
  40.  
  41. # ◊◊◊◊ end changing for new system §3 ◊◊◊◊ #
  42.  
  43. # Carriage return
  44. proc HTMLcarriageReturn {} {
  45.     global indentOnCR mode
  46.     
  47.     if { [isSelection] } { deleteSelection }
  48.     insertText "\r"
  49.     if {$indentOnCR} {
  50.         ${mode}indentLine
  51.         if {![htmlIsWhite [set pre [getText [lineStart [getPos]] [getPos]]]]} {
  52.             regexp {^[ \t]*} $pre white
  53.             goto [expr [lineStart [getPos]] + [string length $white]]
  54.         }
  55.     }
  56. }
  57.  
  58.  
  59. # A boolean function which takes any string and tests to see if
  60. # that string contains all whitespace characters.  Carriage returns 
  61. # are considered whitespace, as are spaces and tabs.
  62. proc htmlIsWhite {anyString} {
  63.     return [regexp {^[ \t\r\n]*$} $anyString]
  64. }
  65.  
  66. # ◊◊◊◊ Change below for new system §4 ◊◊◊◊ #
  67.  
  68. proc htmlAscii {char {num 0}} {
  69.     if {$char == ""} {return 0}
  70.     set str "\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017"
  71.     append str "\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
  72.     append str " !\"#\$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  73.     append str "\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177ÄÅÇÉÑÖÜáàâäãåçéèêë"
  74.     append str "íìîïñóòôöõúùûü†°¢£§•¶ß®©™´¨≠ÆØ∞±≤≥¥µ∂∑∏π∫ªºΩæø¿¡¬√ƒ≈Δ«»… ÀÃÕŒœ–—"
  75.     append str "“”‘’÷◊ÿŸ⁄€‹›fifl‡·‚„‰ÂÊÁËÈÍÎÏÌÓÔÒÚÛÙıˆ˜¯˘˙˚¸˝˛ˇ"
  76.     if {$num} {
  77.         return [string index $str [expr $char - 1]]
  78.     } else {
  79.         return [expr 1 + [string first $char $str]]
  80.     }
  81. }
  82.  
  83. # ◊◊◊◊ end changing for new system §4 ◊◊◊◊ #
  84.  
  85. # Determines the path to the include folder corresponding to path.
  86. # If none, return empty string.
  87. proc htmlWhichInclFolder {path} {
  88.     global HTMLmodeVars
  89.     foreach p $HTMLmodeVars(homePages) {
  90.         if {[string match "[lindex $p 0]:*" $path]} {return [lindex $p 4]:}
  91.     }
  92.     return ""
  93. }
  94.  
  95. proc htmlResolveInclPath {txt path} {
  96.     regsub -nocase {^:INCLUDE:} $txt $path txt
  97.     return $txt
  98. }
  99.  
  100. # Escapes certain characters in URLs.
  101. proc htmlURLescape {str {slash 0}} {
  102.     set hexa {0 1 2 3 4 5 6 7 8 9 A B C D E F}
  103.     set nstr ""
  104.     set exp "\[\001- \177-ˇ%<>\"#\?=&;|\\{\\}\\`^"
  105.     if {$slash} {append exp "/"}
  106.     append exp "\]"
  107.     while {[regexp -indices $exp $str c]} {
  108.         set asc [htmlAscii [string index $str [lindex $c 0]]]
  109.         append nstr [string range $str 0 [expr [lindex $c 0] - 1]]
  110.         append nstr % [lindex $hexa [expr $asc / 16]] [lindex $hexa [expr $asc % 16]]        
  111.         set str [string range $str [expr [lindex $c 1] + 1] end]
  112.     }
  113.     return "$nstr$str"
  114. }
  115.  
  116. proc htmlURLescape2 {str} {
  117.     set url ""
  118.     regexp {[^#]*} $str url
  119.     set anchor [string range $str [string length $url] end]
  120.     return "[htmlURLescape $url]$anchor"
  121. }
  122.  
  123. # Translate escaped characters in URLs.
  124. proc htmlURLunEscape {str} {
  125.     set hexa {0 1 2 3 4 5 6 7 8 9 A B C D E F}
  126.     set nstr ""
  127.     while {[regexp -indices {%[0-9A-F][0-9A-F]} $str hex]} {
  128.         append nstr [string range $str 0 [expr [lindex $hex 0] - 1]]
  129.         append nstr [htmlAscii [expr 16 * [lsearch $hexa [string index $str [expr [lindex $hex 0] + 1]]] \
  130.         + [lsearch $hexa [string index $str [expr [lindex $hex 0] + 2]]]] 1]
  131.         set str [string range $str [expr [lindex $hex 1] + 1] end]
  132.     }
  133.     return "$nstr$str"
  134. }
  135.  
  136. # Adds a URL or window given as input to cache
  137. proc htmlAddToCache {cache newurl} {
  138.     global modifiedModeVars HTMLmodeVars htmlModeIsLoaded
  139.     
  140.     if {$cache == "windows" && [lsearch -exact {_self _top _parent _blank} $newurl] >= 0} {return}
  141.     set URLs $HTMLmodeVars($cache)
  142.     
  143.     if {[string length $newurl] && [lsearch -exact $URLs $newurl] < 0} { 
  144.         set URLs [lsort [lappend URLs $newurl]]
  145.         set HTMLmodeVars($cache) $URLs
  146.         lappend modifiedModeVars [list $cache HTMLmodeVars]
  147.         if {[llength $URLs] == 1 && [info exists htmlModeIsLoaded]} {htmlEnable$cache on}
  148.     }
  149. }
  150.  
  151.  
  152. # Puts up a window with error text.
  153. proc htmlErrorWindow {errHeader errText {cancelButton 0}} {
  154.     
  155.     set errbox "-t {$errHeader} 100 10 400 25"
  156.     set hpos 35
  157.     foreach err $errText {
  158.         lappend errbox -t $err 10 $hpos 400 [expr $hpos + 15]
  159.         incr hpos 20
  160.     }
  161.     if {$cancelButton} {
  162.         lappend errbox -b Cancel 105 [expr $hpos + 20 ] 170 [expr $hpos + 40 ]
  163.     }
  164.     
  165.     set val [eval [concat dialog -w 430 -h [expr $hpos + 50 ] \
  166.     -b OK 20 [expr $hpos + 20 ] 85 [expr $hpos + 40 ] $errbox]]
  167.     return [lindex $val 0]
  168. }
  169.  
  170. # Caches
  171. proc htmlSaveCache {cache text {type html}} {
  172.     global PREFS htmlVersion cssVersion
  173.     if {![file exists $PREFS]} {mkdir $PREFS}
  174.     if {![file exists $PREFS:HTML]} {mkdir $PREFS:HTML}
  175.     set fid [open $PREFS:HTML:$cache w]
  176.     puts $fid "#[set ${type}Version]"
  177.     puts $fid $text
  178.     close $fid
  179. }
  180.  
  181. proc htmlReadCache {cache {type html}} {
  182.     global PREFS htmlVersion cssVersion
  183.     if {![file exists $PREFS:HTML:$cache]} {error "No cache."}
  184.     set fid [open $PREFS:HTML:$cache r]
  185.     gets $fid version
  186.     if {![regexp {^#[0-9]+\.[0-9]+$} $version] || $version != "#[set ${type}Version]"} {
  187.         close $fid
  188.         htmlDeleteCache $cache
  189.         error "Wrong version."
  190.     }
  191.     close $fid
  192.     uplevel #0 [list source $PREFS:HTML:$cache]
  193. }
  194.  
  195. proc htmlDeleteCache {cache} {
  196.     global PREFS
  197.     catch {removeFile $PREFS:HTML:$cache}
  198. }
  199.  
  200. #===============================================================================
  201. # File routines
  202. #===============================================================================
  203.  
  204. # Asks for a file and returns the file name including the relative path from
  205. # current window. For images the width and height are also returned.
  206. proc htmlGetFile {{linkFile ""} {errormsg 0}} {
  207.     upvar pathToNewFile newFile
  208.     # get path to this window.    
  209.     if {![string length [set this [htmlThisFilePath $errormsg]]]} {return}
  210.     
  211.     # Get the file to link to.
  212.     if {$linkFile == "" && [catch {getfile "Select file to link to."} linkFile]} {
  213.         return 
  214.     }
  215.     # For htmlLinkToNewFile
  216.     set newFile $linkFile
  217.     # Get URL for this file?
  218.     set link [htmlBASEfromPath $linkFile]
  219.     if {[lindex $link 4] == "4"} {
  220.         alertnote "You can't link to a file in an include folder."
  221.         return
  222.     }
  223.     if {[lindex $this 0] == [lindex $link 0]} {
  224.         set linkTo [htmlRelativePath "[lindex $this 1][lindex $this 2]" "[lindex $link 1][lindex $link 2]"]
  225.     } else {
  226.         set linkTo [join [lrange $link 0 2] ""]
  227.     }
  228.     set widthheight ""
  229.     if {![file isdirectory $linkFile]} {
  230.         # Check if image file.
  231.         getFileInfo $linkFile arr
  232.         if {$arr(type) == "GIFf"} {
  233.             set widthheight [htmlGIFWidthHeight $linkFile]
  234.         } elseif {$arr(type) =="JPEG" || $arr(type) == "JFIF"} {
  235.             set widthheight [htmlJPEGWidthHeight $linkFile]
  236.         }
  237.     } else {
  238.         append linkTo /
  239.     }
  240.     
  241.     # Add URL to cache.
  242.     htmlAddToCache URLs $linkTo
  243.     return [list $linkTo $widthheight]
  244. }
  245.  
  246.  
  247. # Returns the URL to the current window.
  248. proc htmlThisFilePath {errorMsg} {
  249.     
  250.     set thisFile [stripNameCount [lindex [winNames -f] 0]]
  251.     
  252.     # Look for BASE element.
  253.     if {![catch {search -s -f 1 -r 1 -i 1 -m 0 {<BASE[ \t\r]+[^>]*>} 0} res]} {
  254.         set comm 0
  255.         set commPos 0
  256.         while {![catch {search -s -f 1 -r 0 -m 0 -l [lindex $res 0] {<!--} $commPos} cres]} {
  257.             set comm 1
  258.             if {![catch {search -s -f 1 -r 0 -m 0 -l [lindex $res 0] -- {-->} [expr [lindex $cres 1] + 1]} cres]} {
  259.                 set comm 0
  260.                 set commPos [lindex $cres 1]
  261.             } else {
  262.                 break
  263.             }
  264.         }
  265.         if {!$comm && [regexp -nocase {HREF=\"?([^ \t\r\">]+)} [getText [lindex $res 0] \
  266.         [lindex $res 1]] dum href]} {
  267.             if {[catch {htmlBASEpieces $href} basestr]} {
  268.                 alertnote "Window contains invalid BASE element. Ignored."
  269.             } else {
  270.                 return $basestr
  271.             }
  272.         }
  273.     }
  274.     
  275.     # Check if window is saved.
  276.     if {![file exists $thisFile]} {
  277.         switch $errorMsg {
  278.             0 {
  279.                 set etxt "You must save the window. If you save, you will then be prompted\
  280.                 for a file to link to."
  281.             }
  282.             1 {
  283.                 set etxt "You must save the window, otherwise it cannot be determined\
  284.                 where the link is pointing."
  285.             }
  286.             2 {
  287.                 set etxt "You must save the window, otherwise the link cannot be determined."
  288.             }
  289.             3 {
  290.                 set etxt "You must save the window, otherwise it cannot be determined\
  291.                 where the links are pointing."
  292.             }
  293.             4 {
  294.                 set etxt "You must save the window, otherwise it cannot be determined\
  295.                 where to upload it."
  296.             }
  297.         }
  298.         if {[lindex [dialog -w 400 -h 100 -t $etxt 10 10 390 60  \
  299.         -b Save 20 70  85 90 \
  300.         -b Cancel 110 70 175 90] 1]} {
  301.             return
  302.         }
  303.         
  304.         if {![catch {saveAs "Untitled.html"}]} {
  305.             set thisFile [stripNameCount [lindex [winNames -f] 0]]
  306.         } else {
  307.             return 
  308.         }
  309.     }
  310.     return [htmlBASEfromPath $thisFile]
  311. }
  312.  
  313. # Returns URL to file.
  314. proc htmlBASEfromPath {path} {
  315.     global HTMLmodeVars
  316.     foreach p $HTMLmodeVars(homePages) {
  317.         if {(![set i 0] && [string match "[lindex $p $i]:*" "$path:"]) || 
  318.         ([llength $p] == 5 && [set i 4] && [string match "[lindex $p $i]:*" "$path:"])} {
  319.             set path [string range $path [expr [string length [lindex $p $i]] + 1] end]
  320.             regsub -all {:} $path {/} path
  321.             return [list [lindex $p 1] [lindex $p 2] $path [lindex $p 0] $i [lindex $p 4]]
  322.         }
  323.     }
  324.     regsub -all {:} $path {/} path
  325.     return [list "file:///" "" $path "" 0]
  326. }
  327.  
  328. # Splits a BASE URL in pieces.
  329. # NOTE! That this proc returns a shorter list than the proc above, is used in
  330. # HTMLDblClick to determine if the doc contains a BASE tag.
  331. proc htmlBASEpieces {href} {
  332.     if {[regexp -indices {://} $href css]} {
  333.         if {[set sl [string first / [string range $href [expr [lindex $css 1] + 1] end]]] >=0} {
  334.             set base [string range $href 0 [expr [lindex $css 1] + $sl + 1]]
  335.             set path [string range $href [expr [lindex $css 1] + $sl + 2] end]
  336.             set sl [string last / $path]
  337.             set epath [string range $path [expr $sl + 1] end]
  338.             set path [string range $path 0 $sl]
  339.         } else {
  340.             set base [string range $href 0 [lindex $css 1]]
  341.             set path ""
  342.             set epath [string range $href [expr [lindex $css 1] + 1] end]
  343.         }
  344.         return [list [htmlURLunEscape $base] [htmlURLunEscape $path] [htmlURLunEscape $epath] ""]
  345.     } else {
  346.         error "Invalid BASE."
  347.     }
  348. }
  349.  
  350.  
  351. # Determines width and height of a GIF file.
  352. proc htmlGIFWidthHeight {fil} {
  353.     if {[catch {open $fil r} fid]} {return}
  354.     seek $fid 6 start
  355.     set width [expr [htmlReadOne $fid] + 256 * [htmlAscii [read $fid 1]]]
  356.     set height [expr [htmlReadOne $fid] + 256 * [htmlAscii [read $fid 1]]]
  357.     close $fid
  358.     return [list $width $height]
  359. }
  360.  
  361. # Extracts width and height of a jpeg file.
  362. # Algorithm from the perl script 'wwwimagesize' by
  363. # Alex Knowles, alex@ed.ac.uk
  364. # Andrew Tong, werdna@ugcs.caltech.edu
  365. proc htmlJPEGWidthHeight {fil} {
  366.     if {[catch {open $fil r} fid]} {return}
  367.     if {[htmlAscii [read $fid 1]] != 255 || [htmlAscii [read $fid 1]] != 216} {return}
  368.     set ch ""
  369.     while {![eof $fid]} {
  370.         while {[htmlAscii $ch] != 255 && ![eof $fid]} {set ch [read $fid 1]}
  371.         while {[htmlAscii $ch] == 255 && ![eof $fid]} {set ch [read $fid 1]}
  372.         if {[set asc [htmlAscii $ch]] >= 192 && $asc <= 195} {
  373.             seek $fid 3 current
  374.             set height [expr 256 * [htmlAscii [read $fid 1]] + [htmlReadOne $fid]]
  375.             set width [expr 256 * [htmlAscii [read $fid 1]] + [htmlReadOne $fid]]
  376.             close $fid
  377.             return [list $width $height]
  378.         } else {
  379.             set ln [expr 256 * [htmlAscii [read $fid 1]] + [htmlAscii [read $fid 1]] - 2]
  380.             if {$ln < 0} {break}
  381.             seek $fid $ln current
  382.         }
  383.     }
  384.     close $fid
  385. }
  386.  
  387. # Reads one character from an image file.
  388. # For some mysterious reason 10 and 13 has to be swapped.
  389. proc htmlReadOne {fid} {
  390.     set c [htmlAscii [read $fid 1]]
  391.     if {$c == 13} {
  392.         set c 10
  393.     } elseif {$c == 10} {
  394.         set c 13
  395.     }
  396.     return $c
  397. }
  398.  
  399.  
  400. # Returns toFile including relative path from fromFile.
  401. proc htmlRelativePath {fromFile toFile} {
  402.     # Remove trailing /file from fromFile
  403.     set fromFile [string range $fromFile 0 [expr [string last / $fromFile] - 1]]
  404.  
  405.     set fromdir [split $fromFile /]
  406.     set todir [split $toFile /]
  407.     
  408.     # Remove the common path.
  409.     set i 0
  410.     while {[llength $fromdir] > $i && [llength $todir] > $i \
  411.     && [lindex $fromdir $i] == [lindex $todir $i]} {
  412.         incr i
  413.     }
  414.  
  415.     # Insert ../
  416.     foreach f [lrange $fromdir $i end] {
  417.         append linkTo "../"
  418.     }
  419.     # Add the path.
  420.     append linkTo [join [lrange $todir $i end] /]
  421.     
  422.     return $linkTo
  423. }
  424.  
  425. # Determine the path to the file "linkTo", as linked from "base path epath". 
  426. proc htmlPathToFile {base path epath hpPath linkTo} {
  427.     global  HTMLmodeVars
  428.  
  429.     # Is this a mailto or news URL or anchor?
  430.     if {[regexp {^(mailto:|news:|javascript:)} [string tolower $linkTo]]} {error $linkTo}
  431.     
  432.     # remove /file from epath
  433.     set sl [string last / $epath]
  434.     set efil [string range $epath [expr $sl + 1] end]
  435.     set epath [string range $epath 0 $sl]
  436.  
  437.     # anchor points to efil
  438.     if {[string index $linkTo 0] == "#"} {set linkTo $efil}
  439.     
  440.     # Remove anchor from "linkTo".
  441.     regexp {[^#]*} $linkTo linkTo
  442.     
  443.     # Remove ./ from path
  444.     if {[string range $linkTo 0 1] == "./"} {set linkTo [string range $linkTo 2 end]}
  445.     
  446.     # Relative URL beginning with / is relative to server URL.
  447.     if {[string index $linkTo 0] == "/"} {
  448.         set linkTo "$base[string range $linkTo 1 end]"
  449.     }
  450.     
  451.     # Relative URL?
  452.     if {![regexp  {://} $linkTo]} {
  453.         set fromPath [split [string trimright "${path}$epath" /] /]
  454.         set toPath [split $linkTo /]
  455.         # Back down for every ../
  456.         set i 0
  457.         foreach tp $toPath {
  458.             if {$tp == ".."} {
  459.                 incr i
  460.             } else {
  461.                 break
  462.             }
  463.         }
  464.         if {$i > [llength $fromPath] } {
  465.             error ""
  466.         } else {
  467.             set path1 [join [lrange $fromPath 0 [expr [llength $fromPath] - $i - 1]] /]
  468.             if {[string length $path1]} {append path1 /}
  469.             append path1 [join [lrange $toPath $i end] /]
  470.             if {[string match "$path*" $path1] && [string length $hpPath]} {
  471.                 set pathTo [string range $path1 [string length $path] end]
  472.                 regsub -all {/} $pathTo {:} pathTo
  473.                 set casePath $pathTo
  474.                 set pathTo "$hpPath:$pathTo"
  475.                 if {![file isdirectory $pathTo]} {return [list $pathTo $casePath]}
  476.             } elseif {$base == "file:///"} {
  477.                 regsub -all {/} $path1 {:} pathTo
  478.                 return [list $pathTo $pathTo]
  479.             }
  480.             set linkTo "$base$path1"
  481.         }
  482.     }
  483.  
  484.     foreach hp [concat $HTMLmodeVars(homePages) {{"" file:/// "" ""}}]  {
  485.         if {[string match "[lindex $hp 1][lindex $hp 2]*" $linkTo] ||
  486.         [string trimright "[lindex $hp 1][lindex $hp 2]" /] == $linkTo} {
  487.             set pathTo [string range $linkTo [string length "[lindex $hp 1][lindex $hp 2]"] end]
  488.             regsub -all {/} $pathTo {:} pathTo
  489.             set casePath $pathTo
  490.             set pathTo [string trimleft "[lindex $hp 0]:$pathTo" :]
  491.             # If link to folder, add default file.
  492.             if {[file isdirectory $pathTo]} {
  493.                 set pathTo [string trimright $pathTo :]
  494.                 append pathTo ":[lindex $hp 3]"
  495.                 set casePath [string trimright $casePath :]
  496.                 append casePath ":[lindex $hp 3]"
  497.             }        
  498.             return [list $pathTo [string trimleft $casePath :]]
  499.         }
  500.     }
  501.     error $linkTo
  502. }    
  503.  
  504. #===============================================================================
  505. # Cmd-Double-click
  506. #===============================================================================
  507.  
  508. proc HTMLDblClick {from to} {
  509.     global htmlURLAttr mode 
  510.     global ${mode}modeVars filepats
  511.     
  512.     # Build regular expressions with URL attrs.
  513.     if {$mode == "HTML"} {
  514.         set exp "("
  515.         foreach attr $htmlURLAttr {
  516.             append exp "$attr|"
  517.         }
  518.         set exp [string trimright $exp |]
  519.         append exp ")(\"\[^\">\]+\"|\[^ \\t\\n\\r>\]+)"
  520.     }
  521.  
  522.     set expcss {(url)\(\"?([^\"\)]+)\"?\)}
  523.     # Check if user clicked on a link.
  524.     if {($mode == "HTML" && ![catch {search -s -f 0 -r 1 -i 1 -m 0 $exp $from} res] && [lindex $res 1] > $from) ||
  525.     (![set curl [catch {search -s -f 0 -r 1 -i 1 -m 0 $expcss $from} res]] && [lindex $res 1] > $from)} {
  526.         # Get path to this window.
  527.         if {![string length [set thisURL [htmlThisFilePath 1]]]} {return}
  528.         # Get path to link.
  529.         if {[info exists curl]} {set exp $expcss}
  530.         regexp -nocase $exp [eval getText $res] dum1 dum2 linkTo
  531.         set linkTo [htmlURLunEscape [string trim $linkTo \"]]
  532.         # Anchors points to file itself if no BASE. (No BASE if [llength $thisURL] > 4)
  533.         if {[string index $linkTo 0] == "#" && [llength $thisURL] > 4} {
  534.             if {![catch {search -s -f 1 -r 1 -i 1 -m 0 \
  535.                 "<(\[Aa\]|\[mM\]\[aA\]\[pP\])\[ \t\r\n\]+\[^>\]*\[nN\]\[aA\]\[mM\]\[eE\]=\"?[string range $linkTo 1 end]\"?(>|\[ \t\r\n\]+\[^>\]*>)" 0} anc]} {
  536.                 goto [lindex $anc 0]
  537.             }
  538.             return
  539.         }
  540.         if {[catch {lindex [htmlPathToFile [lindex $thisURL 0] [lindex $thisURL 1] [lindex $thisURL 2] [lindex $thisURL 3] $linkTo] 0} linkToPath]} {
  541.             if {$linkToPath == ""} {
  542.                 message "Link not well-defined."
  543.             } else {
  544.                 message "Link points to $linkToPath. Doesn't map to a file on the disk."
  545.             }
  546.             return
  547.         }
  548.         # Does the file exist? 
  549.         if {[file exists $linkToPath] && ![file isdirectory $linkToPath]} {
  550.             # Is it a text file?
  551.             if {[getFileType $linkToPath] == "TEXT"} {
  552.                 edit -c $linkToPath
  553.             } elseif {[set ${mode}modeVars(openNonTextFile)] && [getFileType $linkToPath] != "APPL"} {
  554.                 launchDoc $linkToPath
  555.             } else {
  556.                 message "[file tail $linkToPath] is not a text file."
  557.             }
  558.         } else {
  559.             set isAnHtmlFile 0
  560.             set sufficies ""
  561.             foreach mm {HTML CSS JScr} {
  562.                 if {[info exists filepats($mm)]} {set sufficies [concat $sufficies $filepats($mm)]}
  563.             }
  564.             foreach suffix $sufficies {
  565.                 if {[string match $suffix $linkToPath]} {set isAnHtmlFile 1}
  566.             }
  567.             if {(![file exists $linkToPath] && !$isAnHtmlFile) || [file isdirectory $linkToPath] ||
  568.             ![regexp {[^:]+} $linkToPath disk] || ![file exists $disk:]} {
  569.                 message "Cannot open [file tail $linkToPath]."
  570.             } else {
  571.                 set htmlFile [file tail $linkToPath]
  572.                 if {[lindex [dialog -w 350 -h 140 -t "The file '$htmlFile' does not exist.\
  573.                 Do you want to open a new empty window with this name?\
  574.                 It will automatically be saved in the right place,\
  575.                 and if necessary, new folders will be created."  10 10 340 100 \
  576.                 -b Yes 20 110 85 130 -b No 115 110 180 130] 1]} {return}
  577.                 # Create a new file and open it.
  578.                 foreach p [split [file dirname $linkToPath] :] {
  579.                     append path "$p:"
  580.                     # make new folders if needed.
  581.                     if {![file exists $path]} {
  582.                         mkdir $path
  583.                     } elseif {![file isdirectory $path]} {
  584.                         alertnote "Cannot make a new folder '[file tail $path]'.\
  585.                         There is already a file with the same name."
  586.                         return
  587.                     }
  588.                 }
  589.                 append path "$htmlFile"
  590.                 # create an empty file.
  591.                 set fid [open $path w]
  592.                 # I suppose it's best to close it, too.
  593.                 close $fid
  594.                 edit $path
  595.             }
  596.         }
  597.     } elseif {$mode == "HTML"} { 
  598.         if {![catch {search -s -f 0 -r 1 -i 1 -m 0 {FILE=\"[^\"]+\"} $from} res] && [lindex $res 1] > $from} {
  599.             regexp -nocase {FILE=\"([^\"]+)\"} [eval getText $res] dum fil
  600.             set fil [htmlResolveInclPath [htmlUnQuote $fil] [htmlWhichInclFolder [stripNameCount [lindex [winNames -f] 0]]]]
  601.             if {[file exists $fil]} {
  602.                 edit -c $fil
  603.             } else {
  604.                 message "File not found."
  605.             }
  606.         } elseif {![htmlRevealColor 1]} {
  607.             htmlChangeDblClick
  608.         }
  609.     }
  610. }
  611.  
  612. #==============================================================================
  613. #    Colors
  614. #==============================================================================
  615.  
  616. # Convert colour names to numbers and vice versa.
  617. # Or brings up a color picker if cmd-doubleClick.
  618. proc htmlRevealColor {{dblClick 0}} {
  619.     global htmlColorName htmlColorNumber htmlColorAttr htmluserColors 
  620.     global htmluserColorname
  621.  
  622.     set searchstring "("
  623.     foreach s $htmlColorAttr {
  624.         append searchstring "${s}|"
  625.     } 
  626.     # remove last |
  627.     set searchstring [string trimright $searchstring |]
  628.     append searchstring ")(\"(\[^\"\]*)\"|(\[^ \\t\\r\">\]*))"
  629.     set startpos [getPos]
  630.     set endpos [selEnd]
  631.     set cantfind 0
  632.     # find attribute
  633.     set f [search -s -f 0 -r 1 -i 1 -n -m 0 $searchstring $startpos]
  634.     if {![string length $f] || [lindex $f 1] < $endpos} {
  635.         set cantfind 1
  636.     }
  637.     if {!$cantfind} {
  638.         set txt [getText [lindex $f 0] [lindex $f 1]]
  639.         regexp -indices -nocase $searchstring $txt a b c
  640.         set cpos [expr [lindex $f 0] + [lindex $c 0]]
  641.         set epos [expr [lindex $f 0] + [lindex $c 1] + 1]
  642.         set col [string trim [string range $txt [lindex $c 0] [lindex $c 1]] \"]
  643.         if {!$dblClick} {
  644.             if {[info exists htmlColorName($col)]} {
  645.                 replaceText $cpos $epos "\"$htmlColorName($col)\""
  646.             } elseif {[info exists htmlColorNumber($col)]} {
  647.                 replaceText $cpos $epos "\"$htmlColorNumber($col)\""
  648.             } elseif {[info exists htmluserColorname($col)]} {
  649.                 replaceText $cpos $epos "\"$htmluserColorname($col)\""
  650.             } elseif {[info exists htmluserColors($col)]} {
  651.                 replaceText $cpos $epos "\"$htmluserColors($col)\""
  652.             } else {
  653.                 beep
  654.                 message "Don't recognize color."
  655.             }
  656.         } else {
  657.             if {[set ncol [htmlCheckColorNumber $col]] != "0"} {
  658.                 set ncol [htmlHexColor $ncol]
  659.             } else {
  660.                 set ncol {65535 65535 65535}
  661.             }
  662.             set newcolor [eval [concat colorTriple {{Change color}} $ncol]]
  663.             if {[string length $newcolor]} {
  664.                 replaceText $cpos $epos "\"[htmlColorHex $newcolor]\""
  665.             }
  666.             return 1
  667.         }
  668.     } elseif {!$dblClick} {
  669.         beep
  670.         message "Current position is not at a color attribute."
  671.     } else {
  672.         return 0
  673.     }
  674. }
  675.  
  676. # Dialog to handle colors.
  677. proc htmlColors {} {
  678.     global htmluserColors
  679.  
  680.     set this ∞
  681.     while {1} {
  682.         set colors [lsort [array names htmluserColors]]
  683.         set box "-t {Colors:} 10 10 80 30 \
  684.         -t Number: 10 50 80 70 \
  685.         -b Done 10 100 75 120 -b New… 90 100 155 120 -b {New by number…} 250 10 375 30"
  686.         if {[llength $colors]} {
  687.             append box " -m [list [concat [list $this] $colors]] 90 10 230 30"
  688.             append box " -b Change… 168 100 237 120 -b Remove 250 100 315 120 \
  689.             -b {Change number…} 250 40 375 60 -b View… 250 70 315 90"
  690.             foreach c $colors {
  691.                 lappend box -n $c -t $htmluserColors($c) 90 50 160 90
  692.             }
  693.         } else {
  694.             append box  " -m {{None defined} {None defined}} 90 10 230 30"
  695.         }
  696.         set values [eval [concat dialog -w 380 -h 130 $box]]
  697.         set this [lindex $values 3]
  698.         if {[lindex $values 0]} {
  699.             return
  700.         } elseif {[lindex $values 1]} {
  701.             set newc [htmlAddNewColor]
  702.             if {[string length $newc]} {set this $newc}
  703.         } elseif {[lindex $values 2]} {
  704.             set newc [htmlNameColor "" "Color saved." "" ""]
  705.             if {[string length $newc]} {set this $newc}
  706.         } elseif {[lindex $values 4]} {
  707.             set newcolor [eval [concat colorTriple [list $this] [htmlHexColor $htmluserColors($this)]]]
  708.             if {![string length $newcolor]} {continue}
  709.             set newc [htmlNameColor [htmlColorHex $newcolor] "Color changed." $this $htmluserColors($this)]
  710.             if {[string length $newc]} {set this $newc}        
  711.         } elseif {[lindex $values 5]} {
  712.             if {[askyesno "Remove $this?"] == "yes"} {
  713.                 htmlColordelete $this $htmluserColors($this)
  714.                 message "Color removed."
  715.             }
  716.         } elseif {[lindex $values 6]} {
  717.             set newc [htmlNameColor "" "Color changed." $this $htmluserColors($this)]
  718.             if {[string length $newc]} {set this $newc}        
  719.         } else {
  720.             eval [concat colorTriple [list $this] [htmlHexColor $htmluserColors($this)]]
  721.         }
  722.     }
  723. }
  724.  
  725. # Checks if colornumber is identical to another colour.
  726. proc htmlColorIdentical {colornumber changeColor} {
  727.     global htmlColorNumber htmluserColorname
  728.     if {( ![catch {set colTest $htmlColorNumber($colornumber)}] || \
  729.     ![catch {set colTest $htmluserColorname($colornumber)}] ) && \
  730.     $colTest != $changeColor} {
  731.         alertnote "This color is identical with '$colTest'. Two identical \
  732.         colors cannot be defined."
  733.         return 1
  734.     }
  735.     return 0
  736. }
  737.  
  738. # Converts a red green blue number to hex.
  739. proc htmlColorHex {color} {
  740.     set hexa {A B C D E F}
  741.     
  742.     set red [expr [set x [expr round([lindex $color 0] / 256.0)]] < 256 ? $x : 255]
  743.     set green [expr [set x [expr round([lindex $color 1] / 256.0)]] < 256 ? $x : 255]
  744.     set blue [expr [set x [expr round([lindex $color 2] / 256.0)]] < 256 ? $x : 255]
  745.     set cols [list [expr $red / 16] [expr $red % 16] [expr $green / 16] [expr $green % 16] [expr $blue / 16] [expr $blue % 16]]
  746.     set colornumber {#}
  747.     foreach c $cols {
  748.         if {$c > 9} {
  749.             set c1 [lindex $hexa [expr $c - 10]]
  750.         } else {
  751.             set c1 $c
  752.         }
  753.         append colornumber $c1
  754.     }
  755.     return $colornumber
  756. }
  757.  
  758. # Converts a hex number to red green blue.
  759. proc htmlHexColor {number} {
  760.     foreach c [split [string range $number 1 end] ""] {
  761.         switch $c {
  762.             A    {set c1 10}
  763.             B    {set c1 11}
  764.             C    {set c1 12}
  765.             D    {set c1 13}
  766.             E    {set c1 14}
  767.             F    {set c1 15}
  768.             default {set c1 $c}
  769.         }
  770.         lappend numbers $c1
  771.     }
  772.     set red [expr [lindex $numbers 0] * 4096 + [lindex $numbers 1] * 256]
  773.     set green [expr [lindex $numbers 2] * 4096 + [lindex $numbers 3] * 256]
  774.     set blue [expr [lindex $numbers 4] * 4096 + [lindex $numbers 5] * 256]
  775.     return [list $red $green $blue]
  776. }    
  777.  
  778. proc htmlAddNewColor {} {
  779.     set newcolor [colorTriple "New color"]    
  780.     if {![string length $newcolor]} {return }
  781.     return [htmlNameColor [htmlColorHex $newcolor] "Color saved." "" ""]
  782. }
  783.  
  784. proc htmlNameColor {colornumber msg changeColor changeNumber} {
  785.     global htmluserColors basicColors
  786.     set alluserColors [array names htmluserColors]
  787.     set noname 1
  788.     set picker [string length $colornumber]
  789.     set values [list $changeColor $changeNumber]
  790.     while {$noname} {
  791.         if {!$picker} {
  792.             if {[string length $changeColor]} {
  793.                 set ttt Change
  794.             } else {
  795.                 set ttt New
  796.             }
  797.             set values [dialog -w 300 -h 150 -t "$ttt color" 50 10 250 30 \
  798.             -t "Name:" 10 45 75 65 -e [lindex $values 0] 80 45 290 60 \
  799.             -t "Number:" 10 75 75 95 -e [lindex $values 1] 80 75 150 90 \
  800.             -b OK 20 120 85 140 -b Cancel 110 120 175 140]
  801.             
  802.             if {[lindex $values 3]} {return}
  803.             set colorname [string trim [lindex $values 0]]
  804.             set colornumber [string trim [lindex $values 1]]
  805.             set coltest [htmlCheckColorNumber $colornumber]
  806.             if {$coltest == "0"} {
  807.                 alertnote "$colornumber is not a valid color number. It should be of the form #RRBBGG."
  808.                 continue
  809.             }
  810.             set colornumber $coltest
  811.             if {[htmlColorIdentical $colornumber $changeColor]} {return}
  812.         } else {
  813.             if {[htmlColorIdentical $colornumber $changeColor]} {return}
  814.             if {[catch {prompt "Color name" $changeColor} colorname]} { 
  815.                 # cancel
  816.                 return
  817.             }
  818.             set colorname [string trim $colorname]
  819.         }
  820.         if {[lsearch -exact $basicColors $colorname] >= 0} {
  821.             alertnote "Predefined color. Choose another name."
  822.         } elseif {[string length $colorname]} {
  823.             set replace 0
  824.             if {[lsearch -exact $alluserColors $colorname] >= 0 && \
  825.             $colorname != $changeColor} {
  826.                 set repl [dialog -w 200 -h 75 -b Cancel 20 40 80 60 \
  827.                 -b Replace 115 40 175 60 \
  828.                 -t "Replace $colorname?" 10 10 150 30]
  829.                 if {[lindex $repl 1] } { 
  830.                     set replace 1
  831.                     # remove the color first 
  832.                     set oldnumber $htmluserColors($colorname)
  833.                     htmlColordelete $colorname $oldnumber
  834.                 }
  835.             } else {
  836.                 set replace 1
  837.             }
  838.             # add the new color
  839.             if {$replace} { 
  840.                 if {[string length $changeColor]} {
  841.                     htmlColordelete $changeColor $changeNumber
  842.                 }
  843.                 set noname 0
  844.                 htmlColordef $colorname $colornumber
  845.                 message $msg
  846.             }
  847.         } else {
  848.             alertnote "You must name the color."
  849.         }
  850.     }
  851.     return $colorname
  852. }
  853.  
  854.  
  855. proc htmlColordef {colorname colornumber} {
  856.     global htmluserColors htmluserColorname
  857.     
  858.     set htmluserColors($colorname) $colornumber
  859.     set htmluserColorname($colornumber) $colorname
  860.     addArrDef htmluserColors $colorname $colornumber
  861.     addArrDef htmluserColorname $colornumber $colorname
  862. }
  863.  
  864. proc htmlColordelete {colorname colornumber} {
  865.     global htmluserColors htmluserColorname
  866.     
  867.     catch {unset htmluserColors($colorname)}
  868.     catch {unset htmluserColorname($colornumber)}
  869.     removeArrDef htmluserColors $colorname
  870.     removeArrDef htmluserColorname $colornumber
  871. }
  872.  
  873.  
  874. # Check if a color number is a valid number, or one of the predefined names.
  875. # Returns 0 if not and the color number if it is.
  876. proc htmlCheckColorNumber {color} {
  877.     global htmlColorName
  878.     set color [string tolower $color]
  879.     if {[info exists htmlColorName($color)]} {return $htmlColorName($color)}
  880.     if {[string index $color 0] != "#"} {
  881.         set color "#${color}"
  882.     }
  883.     set color [string toupper $color]
  884.     if {[string length $color] != 7 || ![regexp {^#[0-9A-F]+$} $color]} {
  885.         return 0
  886.     } else {
  887.         return $color
  888.     }    
  889. }
  890.  
  891. #===============================================================================
  892. # Colors for background, text and links
  893. #===============================================================================
  894.  
  895.  
  896. proc htmlNewColor {var val } {
  897.     global htmlColorName
  898.     global htmlColorNumber
  899.     set htmlColorName($var) $val 
  900.     set htmlColorNumber($val) $var
  901. }
  902. htmlNewColor black        "#000000"
  903. htmlNewColor silver        "#C0C0C0"
  904. htmlNewColor gray        "#808080"
  905. htmlNewColor white        "#FFFFFF"
  906. htmlNewColor maroon        "#800000"
  907. htmlNewColor red        "#FF0000"
  908. htmlNewColor purple        "#800080"
  909. htmlNewColor fuchsia    "#FF00FF"
  910. htmlNewColor green        "#008000"
  911. htmlNewColor lime        "#00FF00"
  912. htmlNewColor olive        "#808000"
  913. htmlNewColor yellow        "#FFFF00"
  914. htmlNewColor navy        "#000080"
  915. htmlNewColor blue        "#0000FF"
  916. htmlNewColor teal        "#008080"
  917. htmlNewColor aqua        "#00FFFF"
  918.  
  919. # Remove colors conflicting with the new ones
  920. foreach tmpCol [array names htmluserColors] {
  921.     if {[info exists htmlColorName($tmpCol)]} {
  922.         htmlColordelete $tmpCol $htmluserColors($tmpCol)
  923.     }
  924. }
  925. foreach tmpCol [array names htmluserColorname] {
  926.     if {[info exists htmlColorNumber($tmpCol)]} {
  927.         htmlColordelete $htmluserColorname($tmpCol) $tmpCol
  928.     }
  929. }
  930. catch {unset tmpCol}
  931. # A list of colours
  932. set basicColors [lsort [array names htmlColorName]]
  933. rename htmlNewColor ""
  934.